;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Quickdraw.lisp
;;
;;  copyright © 1987-89 Apple Computer
;;
;;  This file implements a full error-checked interface to Quickdraw.
;;  It is meant to be useful both in programs and as an example of how to use
;;  the low-level interface to the Mac.
;;
;;  You can compile selected portions of this file, but if you do, make sure to
;;  include the macros and utility functions from the top.
;;


(proclaim '(object-variable wptr))

(eval-when (eval compile)
  (require 'records)
  (require 'traps))

(defmacro with-rectangle-arg ((var left top right bottom) &body body)
  "takes a rectangle, two points, or four coordinates and makes a rectangle.
body is evaluated with VAR bound to that rectangle."
  `(rlet ((,var :rect))
     (cond (,bottom
            (rset ,var rect.topleft (make-point ,left ,top))
            (rset ,var rect.bottomright (make-point ,right ,bottom)))
           (,right
            (error "Illegal rectangle arguments: ~s ~s ~s ~s"
                   ,left ,top ,right ,bottom))
           (,top
            (rset ,var rect.topleft (make-point ,left nil))
            (rset ,var rect.bottomright (make-point ,top nil)))
           (t (setq ,var (pointer-arg ,left))))
     ,@body))

(defun pointer-arg (thing)
  (if (pointerp thing)
      thing
      (error "Argument: ~a is not a Macintosh pointer" thing)))

(defun handle-arg (thing)
  (if (handlep thing)
      thing
      (error "Argument: ~a is not a Macintosh handle" thing)))

(defun region-arg (thing)
  (if (handlep thing)
      thing
      (error "Argument: ~a is not a Macintosh handle" thing)))

(defun polygon-arg (thing)
  (if (handlep thing)
      thing
      (error "Argument: ~a is not a Macintosh handle" thing)))

(defun picture-arg (thing)
  (if (handlep thing)
      thing
      (error "Argument: ~a is not a Macintosh handle" thing)))

(defun mode-arg (thing)
  (or
   (and (fixnump thing) (<= 0 thing 15) thing)
   (position thing *pen-modes*)
   (error "Unknown pen mode: ~a" thing)))

(defobfun (origin *window*) ()
  (rref wptr window.portrect.topleft))

(defobfun (set-origin *window*) (h &optional v &aux (pt (make-point h v)))
  (with-port wptr (_SetOrigin :long pt))
  pt)

(defobfun (clip-region *window*) (&optional (save-region (_NewRgn :ptr)))
 (with-port wptr 
   (_GetClip :ptr (setq save-region (region-arg save-region))))
 save-region)

(defobfun (set-clip-region *window*) (new-region)
 (with-port wptr
   (_SetClip :ptr (region-arg new-region)))
 new-region)

(defobfun (clip-rect *window*) (left &optional top right bot)
  (with-rectangle-arg (r left top right bot)
    (with-port wptr
      (_ClipRect :ptr r)))
  nil)

(defobfun (pen-show *window*) ()
  (rset wptr grafport.pnvis 0)
  nil)

(defobfun (pen-hide *window*) ()
  (rset wptr grafport.pnvis -1)
  nil)

(defobfun (pen-shown-p *window*) ()
  (> (rref wptr grafport.pnvis) -1))

(defobfun (pen-position *window*) ()
 (rref wptr window.pnloc))

(defobfun (pen-size *window*) ()
  (rref wptr window.pnsize))

(defobfun (set-pen-size *window*) (h &optional v &aux (pt (make-point h v)))
  (with-port wptr
    (_PenSize :long pt)
    pt))

(defobfun (pen-mode *window*) ()
  (elt *pen-modes* (rref wptr window.pnmode)))

(defobfun (set-pen-mode *window*) (new-mode)
  (with-port wptr (_PenMode :word (mode-arg new-mode))))

(defobfun (pen-pattern *window*) (&optional (save-pat (make-record :pattern)))
  (copy-record
   (rref wptr window.pnPat) :pattern (pointer-arg save-pat))
  save-pat)

(defobfun (set-pen-pattern *window*) (new-pattern)
  (rset wptr window.pnPat (pointer-arg new-pattern))
  new-pattern)

(defobfun (pen-state *window*) (&optional (save-state (make-record :penstate)))
 (with-port wptr
   (_GetPenState :ptr (pointer-arg save-state)))
 save-state)

(defobfun (set-pen-state *window*) (new-state)
 (with-port wptr
   (_SetPenState :ptr (pointer-arg new-state)))
 new-state)

(defobfun (pen-normal *window*) ()
  (with-port wptr (_PenNormal)))

(defobfun (move-to *window*) (h &optional v)
  (with-port wptr (_MoveTo :long (setq h (make-point h v))))
  h)

(defobfun (move *window*) (h &optional v)
  (with-port wptr (_Move :long (setq h (make-point h v))))
  h)

(defobfun (line-to *window*) (h &optional v)
  "draws a line from current pen position to new position"
  (with-port wptr (_LineTo :long (setq h (make-point h v))))
  h)

(defobfun (line *window*) (h &optional v)
  (with-port wptr (_Line :long (setq h (make-point h v))))
  h)

(defun offset-rect (rect h &optional v)
  (_OffsetRect :ptr (pointer-arg rect) :long (make-point h v))
  rect)

(defun inset-rect (rect h &optional v)
  (_InsetRect :ptr (pointer-arg rect) :long (make-point h v))
  rect)

(defun intersect-rect (rect1 rect2 dest-rect)
  (_SectRect :ptr (pointer-arg rect1) :ptr (pointer-arg rect2)
             :ptr (pointer-arg dest-rect))
  dest-rect)

(defun union-rect (rect1 rect2 dest-rect)
  (_UnionRect :ptr (pointer-arg rect1) :ptr (pointer-arg rect2)
             :ptr (pointer-arg dest-rect))
  dest-rect)

(defun point-in-rect-p (rect h &optional v)
  (logbitp 8 
     (_PtInRect :long (make-point h v) :ptr (pointer-arg rect) :word)))

(defun points-to-rect (point1 point2 dest-rect)
  (_Pt2Rect :long (make-point point1 nil) :long (make-point point2 nil)
            :ptr (pointer-arg dest-rect))
  dest-rect)

(defun point-to-angle (rect h &optional v)
  (%stack-block ((ip 4))
    (_PtToAngle :ptr rect :long (make-point h v) :ptr ip)
    (%get-word ip)))

(defun equal-rect (rect1 rect2)
  (logbitp 8
    (_EqualRect :ptr (pointer-arg rect1) :ptr (pointer-arg rect2) :word)))

(defun empty-rect-p (left &optional top right bot)
  (with-rectangle-arg (r left top right bot)
  (logbitp 8 (_EmptyRect :ptr r :word))))

(defobfun (frame-rect *window*) (left &optional top right bot)
 (with-port wptr
   (with-rectangle-arg (r left top right bot) (_FrameRect :ptr r))))

(defobfun (paint-rect *window*) (left &optional top right bot)
  (with-port wptr
    (with-rectangle-arg (r left top right bot) (_PaintRect :ptr r))))

(defobfun (erase-rect *window*) (left &optional top right bot)
  (with-port wptr
    (with-rectangle-arg (r left top right bot) (_EraseRect :ptr r))))

(defobfun (invert-rect *window*) (left &optional top right bot)
  (with-port wptr
    (with-rectangle-arg (r left top right bot) (_InverRect :ptr r))))

(defobfun (fill-rect *window*) (pattern left &optional top right bot)
  (with-port wptr
    (with-rectangle-arg (r left top right bot)
       (_FillRect :ptr r :ptr (pointer-arg pattern)))))

(defobfun (frame-oval *window*) (left &optional top right bot)
 (with-port wptr
   (with-rectangle-arg (r left top right bot) (_FrameOval :ptr r))))

(defobfun (paint-oval *window*) (left &optional top right bot)
  (with-port wptr
    (with-rectangle-arg (r left top right bot) (_PaintOval :ptr r))))

(defobfun (erase-oval *window*) (left &optional top right bot)
  (with-port wptr
    (with-rectangle-arg (r left top right bot) (_EraseOval :ptr r))))

(defobfun (invert-oval *window*) (left &optional top right bot)
  (with-port wptr
    (with-rectangle-arg (r left top right bot) (_InvertOval :ptr r))))

(defobfun (fill-oval *window*) (pattern left &optional top right bot)
  (with-port wptr
    (with-rectangle-arg (r left top right bot)
       (_FillOval :ptr r :ptr (pointer-arg pattern)))))

(defobfun (frame-round-rect *window*) (oval-width oval-height 
                                                 left &optional top right bot)
 (with-port wptr
   (with-rectangle-arg (r left top right bot)
      (_FrameRoundRect :ptr r :word oval-width :word oval-height))))

(defobfun (paint-round-rect *window*) (oval-width oval-height 
                                                 left &optional top right bot)
 (with-port wptr
   (with-rectangle-arg (r left top right bot)
      (_PaintRoundRect :ptr r :word oval-width :word oval-height))))

(defobfun (erase-round-rect *window*) (oval-width oval-height 
                                                 left &optional top right bot)
 (with-port wptr
   (with-rectangle-arg (r left top right bot)
      (_EraseRoundRect :ptr r :word oval-width :word oval-height))))

(defobfun (invert-round-rect *window*) (oval-width oval-height 
                                                 left &optional top right bot)
 (with-port wptr
   (with-rectangle-arg (r left top right bot)
      (_InverRoundRect :ptr r :word oval-width :word oval-height))))

(defobfun (fill-round-rect *window*) (pattern oval-width oval-height 
                                       left &optional top right bot)
  (with-port wptr
    (with-rectangle-arg (r left top right bot)
       (_FillRoundRect :ptr r :word oval-width :word oval-height
                       :ptr (pointer-arg pattern)))))

(defobfun (frame-arc *window*) (start-angle arc-angle 
                                                 left &optional top right bot)
 (with-port wptr
   (with-rectangle-arg (r left top right bot)
      (_FrameArc :ptr r :word start-angle :word arc-angle))))

(defobfun (paint-arc *window*) (start-angle arc-angle 
                                                 left &optional top right bot)
 (with-port wptr
   (with-rectangle-arg (r left top right bot)
      (_PaintArc :ptr r :word start-angle :word arc-angle))))

(defobfun (erase-arc *window*) (start-angle arc-angle 
                                                 left &optional top right bot)
 (with-port wptr
   (with-rectangle-arg (r left top right bot)
      (_EraseArc :ptr r :word start-angle :word arc-angle))))

(defobfun (invert-arc *window*) (start-angle arc-angle 
                                                 left &optional top right bot)
 (with-port wptr
   (with-rectangle-arg (r left top right bot)
      (_InvertArc :ptr r :word start-angle :word arc-angle))))

(defobfun (fill-arc *window*) (pattern start-angle arc-angle
                                       left &optional top right bot)
  (with-port wptr
    (with-rectangle-arg (r left top right bot)
       (_FillArc :ptr r :word start-angle :word arc-angle
                 :ptr (pointer-arg pattern)))))

;;;Regions

(defun new-region ()
  (_NewRgn :ptr))

(defun dispose-region (region)
  (_DisposRgn :ptr (region-arg region)))

(defun copy-region (region &optional (dest-region (new-region)))
  (_CopyRgn :ptr (region-arg region) :ptr (region-arg dest-region))
  dest-region)

(defun set-empty-region (region)
  (_SetEmptyRgn :ptr (region-arg region))
  region)

(defun set-rect-region (region left &optional top right bot)
  (with-rectangle-arg (r left top right bot)
   (_RectRgn :ptr (region-arg region) :ptr r))
  region)

(defobfun (open-region *window*) ()
  (if (rref wptr window.rgnSave)
      (error "Region already open for window: ~a" (self)))
  (with-port wptr (_OpenRgn)))

(defobfun (close-region *window*) (&optional (dest-region (new-region) dp))
  (if (not (rref wptr window.rgnSave))
      (progn 
       (if (not dp) (dispose-region dest-region))
       (error "Region is not open for window: ~a" (self))))
  (with-port wptr
    (_CloseRgn :ptr (region-arg dest-region)))
  dest-region)

(defun offset-region (region h &optional v)
  (_OffsetRgn :ptr (region-arg region) :long (make-point h v))
  region)

(defun inset-region (region h &optional v)
  (_InsetRgn :ptr (region-arg region) :long (make-point h v))
  region)

(defun intersect-region (region1 region2 &optional (dest-region (new-region)))
  (_SectRgn :ptr (region-arg region1) :ptr (region-arg region2)
            :ptr (region-arg dest-region))
  dest-region)

(defun union-region (region1 region2 &optional (dest-region (new-region)))
  (_UnionRgn :ptr (region-arg region1) :ptr (region-arg region2)
            :ptr (region-arg dest-region))
  dest-region)

(defun difference-region (region1 region2 &optional (dest-region (new-region)))
  (_DiffRgn :ptr (region-arg region1) :ptr (region-arg region2)
            :ptr (region-arg dest-region))
  dest-region)

(defun xor-region (region1 region2 &optional (dest-region (new-region)))
  (_XorRgn :ptr (region-arg region1) :ptr (region-arg region2)
            :ptr (region-arg dest-region))
  dest-region)

(defun point-in-region-p (region h &optional v)
  (logbitp 8 
    (_PtInRgn :long (make-point h v) :ptr (region-arg region) :word)))

(defun rect-in-region-p (region left &optional top right bot)
 (with-rectangle-arg (r left top right bot)
  (logbitp 8 (_RectInRgn :ptr r :ptr (region-arg region) :word))))

(defun equal-region-p (region1 region2)
  (logbitp 8 
     (_EqualRgn :ptr (region-arg region1) :ptr (region-arg region2) :word)))

(defun empty-region-p (region)
   (logbitp 8 (_EmptyRgn :ptr (region-arg region) :word)))

(defobfun (frame-region *window*) (region)
  (with-port wptr (_FrameRgn :ptr (region-arg region))))

(defobfun (paint-region *window*) (region)
  (with-port wptr (_PaintRgn :ptr (region-arg region))))

(defobfun (erase-region *window*) (region)
  (with-port wptr (_EraseRgn :ptr (region-arg region))))

(defobfun (invert-region *window*) (region)
  (with-port wptr (_InverRgn :ptr (region-arg region))))

(defobfun (fill-region *window*) (pattern region)
  (with-port wptr 
    (_FillRgn :ptr (region-arg region) :ptr (pointer-arg pattern))))

;;;Pictures

(defobfun (start-picture *window*) (&optional left top right bottom)
  (if (rref wptr window.picsave)
   (error "A picture may not be started for window: ~a.
           since one is already started" (self)))
 (unless left (setq left (rref wptr window.portrect)))
 (with-rectangle-arg (r left top right bottom)
  (with-port wptr (have 'my-hPic (_OpenPicture :ptr r :ptr))))
 nil)

(defobfun (get-picture *window*) ()
  (declare (object-variable my-hPic))
 (if (and (boundp 'my-hPic) my-hPic (rref wptr window.picSave))
  (prog1
    my-hPic
    (with-port wptr (_ClosePicture))
    (setq my-hPic nil))
  (error "Picture for window: ~a is not started" (self))))

(defobfun (draw-picture *window*) (picture &optional left top right bottom)
 (setq picture (picture-arg picture))
 (cond ((not left)
        (setq left (rref picture picture.picFrame.topleft)
              top (rref picture picture.picFrame.bottomright)))
       ((pointerp left)
        ())
       ((and (not right)
             (not top))
        (print (point-string
                (setq top
                      (add-points left
                                  (subtract-points
                                   (rref picture picture.picframe.bottomright)
                                   (rref picture picture.picframe.topleft))))))))
 (with-rectangle-arg (r left top right bottom)
   (with-port wptr
     (_DrawPicture :ptr picture :ptr r))))

(defun kill-picture (picture)
  (_KillPicture :ptr (picture-arg picture)))

(defobfun (start-polygon *window*) ()
 (if (rref wptr window.polysave)
   (error "A new polygon may not be started for window: ~a.
           since one is already started" (self)))
 (with-port wptr (have 'my-poly (_OpenPoly :ptr)))
 nil)

(defobfun (get-polygon *window*) ()
  (declare (object-variable my-poly))
 (if (and (boundp 'my-poly) my-poly (rref wptr window.polysave))
     (prog1
       my-poly
       (with-port wptr (_ClosePgon))
       (setq my-poly nil))
     (error "Polygon for window: ~a has not been started" (self))))

(defun kill-polygon (polygon)
  (_KillPoly :ptr (polygon-arg polygon)))

(defun offset-polygon (polygon h &optional v)
  (_OffsetPoly :ptr (polygon-arg polygon) :long (make-point h v))
  polygon)

(defobfun (frame-polygon *window*) (polygon)
  (with-port wptr (_FramePoly :ptr (polygon-arg polygon))))

(defobfun (paint-polygon *window*) (polygon)
  (with-port wptr (_PaintPoly :ptr (polygon-arg polygon))))

(defobfun (erase-polygon *window*) (polygon)
  (with-port wptr (_ErasePoly :ptr (polygon-arg polygon))))

(defobfun (invert-polygon *window*) (polygon)
  (with-port wptr (_InvertPoly :ptr (polygon-arg polygon))))

(defobfun (fill-polygon *window*) (pattern polygon)
 (with-port wptr
   (_FillPoly :ptr (polygon-arg polygon) :ptr (pointer-arg pattern))))

(defobfun (local-to-global *window*) (h &optional v)
  (subtract-points (make-point h v)
                   (rref wptr grafport.portbits.bounds.topleft)))

(defobfun (global-to-local *window*) (h &optional v)
  (add-points (make-point h v)
              (rref wptr grafport.portbits.bounds.topleft)))

(defobfun (get-pixel *window*) (h &optional v)
  (setq h (make-point h v))
  (if (logbitp 8 
         (_PtInRgn :long h :ptr (rref wptr window.visrgn) :word))
      (with-port wptr
         (logbitp 8 (_GetPixel :long h :word)))))

(defun scale-point (source-rect dest-rect h &optional v)
  (rlet ((pt :point))
    (%put-long pt (make-point h v))
    (_ScalePt :ptr pt :ptr (pointer-arg source-rect)
                      :ptr (pointer-arg dest-rect))
    (%get-long pt)))

(defun map-point (source-rect dest-rect h &optional v)
  (rlet ((pt :point))
    (%put-long pt (make-point h v))
    (_MapPt :ptr pt :ptr (pointer-arg source-rect)
                      :ptr (pointer-arg dest-rect))
    (%get-long pt)))

(defun map-rect (source-rect dest-rect rect)
   (_MapRect :ptr (pointer-arg rect)
             :ptr (pointer-arg source-rect)
             :ptr (pointer-arg dest-rect))
   rect)

(defun map-region (source-rect dest-rect region)
   (_MapRgn :ptr (region-arg region)
             :ptr (pointer-arg source-rect)
             :ptr (pointer-arg dest-rect))
   region)

(defun map-polygon (source-rect dest-rect polygon)
   (_MapPoly :ptr (polygon-arg polygon)
             :ptr (pointer-arg source-rect)
             :ptr (pointer-arg dest-rect))
   polygon)

(defun make-bitmap (left &optional top right bottom &aux rowbytes bm)
 (with-rectangle-arg (r left top right bottom)
   (setq rowbytes 
    (logand
       #xfffe 
       (+ 2  (ash (- (rref r rect.right) (rref r rect.left) 1) -3))))
   (setq bm 
    (_NewPtr :errchk 
      :d0 (+ 14 (* rowbytes (- (rref r rect.bottom) (rref r rect.top))))
      :a0))
   (rset bm bitmap.bounds r)
   (rset bm bitmap.rowbytes rowbytes)
   (rset bm bitmap.baseaddr (%inc-ptr bm 14)))
 bm)


(defun copy-bits (source-bitmap dest-bitmap source-rect dest-rect
                    &optional (mode 0) mask-region)
 (setq mask-region (if mask-region (region-arg mask-region)))
 (_CopyBits :ptr (pointer-arg source-bitmap)
            :ptr (pointer-arg dest-bitmap)
            :ptr (pointer-arg source-rect)
            :ptr (pointer-arg dest-rect)
            :word (mode-arg mode)
            :ptr mask-region))

(defobfun (scroll-rect *window*) (rect dh &optional dv)
   (with-port wptr
     (let* ((reg (_newrgn :ptr)))
       (_ScrollRect :ptr (pointer-arg rect)
                    :long (make-point dh dv)
                    :ptr reg)
       (_invalrgn :ptr reg)
       (_disposrgn :ptr reg))))



(provide 'quickdraw)
(unless (member :quickdraw *features*)
  (push :quickdraw *features*))